home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / pas_0593.zip / TEXTUNIT.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-30  |  10KB  |  278 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 346 of 411
  3. From : Norbert Igl                         2:2402/300.3         15 May 93  14:10
  4. To   : Raphael Vanney                      2:320/7.0
  5. Subj : Pardon if repeat
  6. ────────────────────────────────────────────────────────────────────────────────
  7. Hello Raphael!
  8. One of these days, Raphael Vanney wrote to Matt Giwer:
  9.  
  10. RV> One cannot seek in a text file...
  11.  
  12.     hmmmmm.... sorry for the german remarks....}
  13. {
  14.                               TEXTEXT.PAS
  15.                           von Bernhard Arnold
  16.                            PFEFFER@DUISSY.ZER
  17.                                  1.4.93
  18.  
  19.                    Seek, Filesize,  FilePos, Blockread
  20.                    und Blockwrite auch fuer Textdateien
  21.  
  22.                       und (neu!) ein relativer Seek
  23.                       und (neu!) ein echtes eof()
  24.  
  25.   Files vom Typ text haben den grossen Vorteil, dass Turbopascal bereits
  26.   eine wunderbare Bufferung vornimmt. Dieser Buffer ist standardmaessig
  27.   128 Bytes gross, sodass sich eine Vergroesserung mittels SetTextbuf sehr
  28.   empfiehlt. Leider haben die Herren  Borland aus mir unerfindlichen
  29.   Gruenden den Zugriff auf text-Files auf Zeilen- oder Byteweises
  30.   sequentielles lesen/schreiben beschraenkt - obwohl die Bufferung
  31.   text-Files eigentlich sehr attraktiv machen. Mit dieser Unit werden
  32.   alel Vorteile aller Filetypen vereint indem die folgende Funktionen
  33.   auch fuer Textfiles zugaenglich gemacht werden:
  34.        FilePos,
  35.        FileSize,
  36.        Seek,
  37.        BlockRead sowie
  38.        Blockwrite.
  39.  
  40.   Damit nicht genug: Um die laestige Dateiendekennung $1A zu umgehen,
  41.   habe habe ich BinEof hinzugefuegt, das wirklich nur dann eof anzeigt,
  42.   wenn die Datei tatsaechlich am Ende ist.
  43.  
  44.   Zuguterletzt noch eine letze Funktion: TextSeekRel.
  45.   Der relative Seek ist so einfach und schnell, und seine Umschreibung
  46.   TextSeek(f, TextFilePos(f)+Pos) ist so umstaendlich und Zeitaufwendig,
  47.   dass ich einfach nicht widerstehen konnte
  48.  
  49.   Diese Idee dieser Unit  stammt   urspruenglich  aus  einer c't,  welche
  50.   genau, weiss ich nicht mehr. Die Unit musste komplett ueberarbytet werden,
  51.   sie war extrem baufaellig.
  52.  
  53.   Ich finde das ganze hochgenial und benutze es u.a. fuer ZNetz-Puffer:
  54.   Den  Nachrichtenkopf  kann ich bequem mit Read- und Writeln einlesen
  55.   bzw. ausgeben,  den  Inhalt mit  den neuen  TextBlockread und -write
  56.   lesen und schreiben bzw. mit TextSeekRel ueberspringen.
  57.  
  58.   Einer  ausgiebigen  Nutzung steht nichts im Wege. Dieser Source ist
  59.   PD, wer was dran aendert, schickt mir bitte ne Kopie.
  60.   Meine E-Mail-Adresse lautet PFEFFER@DUISSY.zer.sub.org.
  61.  
  62.   Die, die die Unit nutzen, und besonders die, die  damit Geld machen,
  63.   und  alle  anderen,  die  mir  ne  Freude machen wollen,  bitte ich,
  64.   mir  was  zu  ueberweisen  auf  das  Konto  Bernhard  Arnold,  Essen,
  65.   Nr. 46 109 528   bei  der  Stadtsparkasse   Essen,  BLZ: 360 501 05.
  66.   Ich denk da an ca. 5-25 DM, mehr ist aber wie  immer willkommen.  Je
  67.   nachdem wieviel Geld ihr mit Eurem Programm macht.
  68.  
  69.   Viel Spass !
  70.  
  71. }
  72.  
  73. unit TextUnit;
  74.  
  75. interface
  76.  
  77. {$B-,D-,E-,I-,L-,N-,X+}
  78.  
  79. uses dos;
  80.  
  81.   function TextFilePos(var andle:text):LongInt;        { wie FilePos    }
  82.   function TextFileSize(var andle:text):LongInt;       { wie FileSize   }
  83.   procedure TextSeek(var andle:text;Pos:LongInt);      { wie Seek       }
  84.   procedure TextBlockread(var andle:text; var buf;     { wie Blockread  }
  85.                       count:word; var result:word);
  86.   procedure TextBlockwrite(var andle:text;  var buf;   { wie Blockwrite }
  87.                         count:word; var result:word);
  88.   function BinEof(var andle:text):boolean;             { eof ohne $1a   }
  89.   function TextSeekRel(var andle:text; Count:Longint):longint;
  90.                                                        { Relativer Seek }
  91.        { Gibt *manchmal* die tatsaechliche Position nach dem Seek }
  92.        { zurueck, naemlich immer dann, wenn count negativ war oder }
  93.        { die gesuchte Position nicht innerhalb des Buffers lag.  }
  94.        { Sonst gibt sie maxlongint zurueck.                       }
  95.        { So ist sie am optimiertesten.                           }
  96.  
  97.  
  98.  
  99. implementation
  100.  
  101. const
  102.   ab_anfang=0;     { Konstanten fuer "wie" von DosSeek }
  103.   ab_jetzig=1;
  104.   ab_ende=2;
  105.  
  106. function DosSeek(Handle:word; Pos:LongInt; wie:byte):longint;
  107. type dword=array[0..1] of word;          { Ruft die Filepositionierungs- }
  108. var Regs:Registers;                      { routine von Int 21h auf.      }
  109.     erg:longint;
  110. begin
  111.   with Regs do begin
  112.     ah:=$42;
  113.     al:=wie;
  114.     bx:=Handle;                 { DOS-Handle }
  115.     cx:=dword(Pos)[1];          { Hi-Word der Position }
  116.     dx:=dword(Pos)[0];          { Lo-Word der Position }
  117.     MSDOS(Regs);
  118.     if Flags and fCarry<>0 then begin
  119.       InOutRes:=ax;
  120.       erg:=0
  121.       end
  122.       else erg:=regs.ax+regs.dx*65536;
  123.   end;
  124.   DosSeek:=erg;
  125. end;
  126.  
  127. function TextFilePos(var andle:text):LongInt;
  128. var erg:longint;
  129. begin
  130.   erg:=DosSeek(Textrec(andle).Handle, 0, ab_jetzig) { Liefert Position }
  131.                    -TextRec(andle).BufEnd           { Buffer beachten  }
  132.                    +TextRec(andle).BufPos;
  133.    Textfilepos:=erg;
  134. end;
  135.  
  136. function TextFileSize(var andle:text):LongInt;
  137. var TempPtr, erg:LongInt;
  138. begin
  139.   case TextRec(andle).Mode of
  140.     fmInput:with Textrec(andle) do begin
  141.               TempPtr:=DosSeek(Handle, 0, ab_jetzig); { Aktuelle merken }
  142.               erg:=DosSeek(Handle, 0, ab_ende);       { einmal ans Ende }
  143.               DosSeek(Handle, TempPtr, ab_anfang);  { und wieder zurueck }
  144.             end;
  145.     fmOutput:erg:=TextFilePos(andle); { Immer am Ende }
  146.     else begin
  147.       erg:=0;                         { Fehlerbehandlung }
  148.       InOutRes:=1;
  149.     end;
  150.   end;
  151.   TextFileSize:=erg;
  152. end;
  153.  
  154. procedure TextSeek(var andle:text; Pos:LongInt);
  155. var aktpos:longint;
  156. begin
  157.   aktpos:=TextFilePos(andle);
  158.   if aktpos<>pos then with Textrec(andle) do begin
  159.     if Mode=fmOutput then flush(andle);
  160.     with Textrec(andle) do begin
  161.       if (aktpos+(bufend-bufpos)<Pos) or (aktpos>Pos) then
  162.        begin   { Wenn gewuenschte Pos nicht innerhalb des Buffers liegt }
  163.         bufpos:=0;          {TP-Puffer}
  164.         bufend:=0;          {zuruecksetzen}
  165.         DosSeek(Textrec(andle).Handle, pos, ab_anfang);
  166.        end
  167.        else begin
  168.          inc(bufpos, pos-aktpos); { vielleicht kann man auch noch ein- }
  169.        end; { if (aktpos... }     { bauen, dass beim zurueckseeken der   }
  170.       end;                        { Buffer genutzt wird, weiss aber     }
  171.   end;                            { nicht, ob das sicher ist und       }
  172. end;                              { brauch es (noch) nicht.            }
  173.  
  174. procedure TextBlockread(var andle:text; var buf; count:word; var result:word);
  175. var R:Registers;
  176.     noch, ausbuf:word;
  177.     posintextbuf:pointer;
  178. begin
  179.   if Textrec(andle).Mode<>fmInput then InOutRes:=1
  180.    else begin
  181.     with Textrec(andle) do
  182.      begin
  183.        noch:=bufend-bufpos;             { Anzahl Zeichen noch im Buffer }
  184.        if noch<>0 then
  185.          begin                                     { noch was im Buffer }
  186.             if noch<count then ausbuf:=noch else ausbuf:=count;
  187.                                                   { reicht der Buffer ? }
  188.            posintextbuf:=pointer(longint(bufptr)+bufpos);
  189.            move(posintextbuf^, buf, ausbuf);
  190.            inc(bufpos, ausbuf);
  191.          end;
  192.      end;
  193.     if noch<count then with r do   { noch nicht alles ? }
  194.       begin
  195.         ds:=Seg(buf);                   { wohin soll }
  196.         dx:=Ofs(Buf)+noch;          { gelesen werden }
  197.         ah:=$3f;                       { Datei lesen }
  198.         bx:=Textrec(andle).Handle;      { DOS-Handle }
  199.         cx:=count-noch;                       { Rest }
  200.         MsDos(R);                  { INT 21 aufrufen }
  201.         if Flags and fCarry<>0
  202.           then InOutRes:=ax                 { Fehler }
  203.           else result:=ax+noch;   { Anzahl gelesener }
  204.       end  { if noch<count }
  205.       else result:=count;
  206.    end; { if Mode=input }
  207. end;
  208.  
  209. procedure TextBlockwrite(var andle:text; var buf; count:word;var result:word);
  210. var r:registers;
  211.     posintextbuf:pointer;
  212. begin
  213.   if Textrec(andle).Mode<>fmOutput then InOutRes:=1
  214.    else begin
  215.      with Textrec(andle) do begin
  216.        if (bufsize-bufpos)>count then          { noch Platz im Buffer ? }
  217.         begin
  218.           posintextbuf:=pointer(longint(bufptr)+bufpos);
  219.           move(buf, posintextbuf^, count);
  220.           inc(bufpos, count);
  221.         end
  222.         else begin
  223.           flush(andle);             {   Puffer leeren }
  224.           with r do begin
  225.             ah:=$40;                { Datei schreiben }
  226.             cx:=count;              {         Wieviel }
  227.             ds:=seg(buf);           {             Was }
  228.             dx:=ofs(buf);
  229.             bx:=Handle;                { Welche Datei }
  230.             MsDos(r);                       { Abschuss }
  231.             if Flags and fCarry<>0 then InOutRes:=ax { Feeler           }
  232.                                    else Result:=ax;  { Anz. geschrieben }
  233.           end;  { with r }
  234.         end;  { if Platz im Buffer else }
  235.        end; { with Textrec }
  236.    end;
  237. end;
  238.  
  239. function TextSeekRel(var andle:text; count:longint):longint;
  240. var ziel, erg:longint;
  241. begin
  242.   with Textrec(andle) do begin
  243.     if Mode=fmOutput then begin InOutRes:=1; exit; end;
  244.     if (count<0) then
  245.       begin
  246.         ziel:=TextFilePos(andle)+count;
  247.         if ziel<0 then ziel:=0;
  248.         TextSeek(andle, ziel);
  249.         erg:=ziel;
  250.       end
  251.     else if ((bufend-bufpos)<Count) then
  252.       begin
  253.         ziel:=count-(bufend-bufpos);
  254.         if ziel<0 then ziel:=0;
  255.         erg:=DosSeek(Textrec(andle).Handle, ziel, ab_jetzig);
  256.         bufpos:=0; bufend:=0;
  257.       end
  258.       else begin
  259.         inc(bufpos, count);  { Maximale Geschwindigkeit }
  260.         erg:=maxlongint;
  261.       end;
  262.   TextSeekRel:=erg;
  263.   end;
  264. end;
  265.  
  266.  
  267. function BinEof(var andle:text):boolean;  { eof ohne $1a   }
  268. var e:boolean;
  269. begin
  270.   e:=eof(andle);
  271. {$R-}  { Array ist nicht begrenzt }
  272.   with textrec(andle) do
  273.     BinEof:=e and (bufptr^[bufpos]<>#$1a);
  274. {$R+}
  275. end;
  276.  
  277.  
  278. end.